home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / format-compiler.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  2KB  |  66 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. ;;; HEY! This stuff isn't used. Maybe we'll just use the much
  4. ;;; more complete (though less efficient) format compiler in
  5. ;;; the pprint stuff.
  6.  
  7. ;;; A simple format compiler. Used as a source-level optimizer.
  8.  
  9. ;(define-compiler-macro-w format (&whole form stream string &rest args)
  10. ;  (compile-format form stream str args))
  11.  
  12. ;;; Things to add:
  13. ;;;    LET bind format args if they are to be used more than once
  14. ;;;    prefix args
  15. (defun compile-format (whole stream-form str args)
  16.   (let ((stream (if (or (not (atom stream-form)) (null stream-form))
  17.             (gensym "STREAM")
  18.             stream-form)))
  19.     (flet ((write-const-string (start end)
  20.          (if (= start end)
  21.          nil
  22.          `((write-string ,(subseq str start end) ,stream)))))
  23.       (iterate munch ((start 0)
  24.               (end 0)
  25.               (argi 0)
  26.               (out nil))
  27.     (cond ((>= end (length str))
  28.            (let ((body (reverse (append (write-const-string
  29.                          start end)
  30.                         out))))
  31.          (if (eq stream-form stream)
  32.              `(progn ,@body nil)
  33.              (if (null stream-form)
  34.              `(with-output-to-string (,stream)
  35.                ,@body)
  36.              `(let ((,stream ,stream-form))
  37.                ,@body
  38.                nil)))))
  39.           ((char= (aref str end) #\~)
  40.            ;; Ignore prefix args. Assume cmd char next
  41.            (let* ((const-str (write-const-string start end))
  42.               (next-arg (if (< argi (length args))
  43.                     (elt args argi)
  44.                     nil))
  45.               (form (case (char-upcase (aref str (1+ end)))
  46.                   (#\A `(princ ,next-arg ,stream))
  47.                   (#\S `(prin1 ,next-arg ,stream))
  48.                   (#\C `(write-char ,next-arg ,stream))
  49.                   (#\% `(terpri ,stream))
  50.                   (#\X `(write ,next-arg :base 16 :stream ,stream))
  51.                   (#\D `(write ,next-arg :base 10 :stream ,stream))
  52.                   (#\O `(write ,next-arg :base 8 :stream ,stream))
  53.                   (#\B `(write ,next-arg :base 2 :stream ,stream))
  54.                   ;; This case could be more efficient.
  55.                   (#\~ `(write-string "~" ,stream))
  56.                   (t :abort)))) ; punt on cmds we don't know
  57.          (case form
  58.            (:abort whole)
  59.            (t (munch (+ end 2)
  60.                  (+ end 2)
  61.                  (1+ argi)
  62.                  (cons form (append const-str out)))))))
  63.           (t (munch start (1+ end) argi out)))))))
  64.  
  65.  
  66.